Pascal Super Library/Pascal Super Library (CW International)(1997).bin/LIBRARY/PBLIB1/UNITS/PBMEMO.PAS

Pascal/Delphi Source File | 1994-05-03 | 11KB | 357 lines

{SECTION ..PbMEMO }
UNIT PbMEMO;

INTERFACE

uses PbMISC, PbOBJS, PbDBOBJ;

{
Description : Dbase MEMO object

Author      : Howard Richoux
Date        : 1/9/94
Last revised: 2/18/94 NEW LIBRARIES
Application : IBM PC and compatibles, done in Turbo Pascal 7
Status      : Placed in the Public Domain by HNR Software 1/29/1994
Published in: none
}

{SECTION .MEMO_object }


const mblksize = 512;
type  MemoNdx     = longint;
type  MEMObuftype = Array[1..mblksize] of byte;

type MEMO_object = object(BFILE_object)
        mbuf     : MEMObuftype;
        recs     : MemoNdx;
        Procedure init    ( fname: string;  dbfmode  : integer);
        Function  fetchN  ( ndx  : MemoNdx; var memo : STRA_object;
                            var blocks : integer) : boolean;
        Function  storeN  ( var memo : STRA_object; var ndx  : MemoNdx;
                            var blocks : integer) : boolean;
        Function  append  ( var memo : STRA_object; var ndx : MemoNdx;
                            var blocks : integer) : boolean;
        Function  MemoBlocksN ( ndx : MemoNdx) : integer;
        Procedure ReadHeader;
        Procedure UpdateHeader;
        Procedure done;
        end;


Procedure PrepareSTRAforOutput(var memo : STRA_object);

{SECTION .ZIMPLEMENTATION }
IMPLEMENTATION
{Notes:
From ALPHA4 v3 - memo block structure:                       I put on string

   $8D = soft CR for word wrap                                 $8D
   $0D = hard CR shows as paragraph symbol                     nothing
   $0A = line feed - terminates string                         nothing
   $1A = end-of-MEMO marker                                    $FE

So if a STRA memo line ends in:
   $8D the load buffer routine appends a $0A
No $8D gets $8D $0A
last line gets $FE --> $1A

}

{SECTION  LoadSTRAfromBuf }
Procedure LoadSTRAfromBuf(var buf : MEMObuftype; var memo : STRA_object;
                            var endflag : boolean; var s : string);
{ need to be handed an initialized STRA object, s can contain a partial
   string from a previous buffer. Calling program sets s:= ''; first time}
var i  : integer;
    ok,done : boolean;
     begin
     endflag := false; done := false;
     i := 0;
     while (i < 512) and not done do
          begin
          inc(i);
          if buf[i] = $1A then
               begin
               endflag := true;
               done := true;
               if length(s) > 0 then ok := memo.append(s+chr($FE));
               end
          else if buf[i] = $0A then
               begin
               s := s + chr($8A);
               ok := memo.append(s);
               s := '';
               end
          else s := s + chr(buf[i]);
          end;
     end;



{SECTION  PrepareSTRAforOutput }
Procedure PrepareSTRAforOutput(var memo : STRA_object);
var s    : string;
    by   : byte;
    i    : integer;
     begin
     if memo.count = 0 then   { if empty memo, just put end-marker }
          begin
          s := chr($FE);
          memo.append(s);
          exit;
          end;

     for i := 1 to memo.count do
          begin
          s := memo.fetchN(i);
          by := byte(s[length(s)]);
          if  by <> $8A then
               begin
               s := s + chr($8D) + chr($8A);
               memo.storeN(i,s);
               end;
          if i = memo.count then
               begin
               s := memo.fetchN(i);
               by := byte(s[length(s)]);
               if  by <> $FE then
                    begin
                    s := s + chr($FE);
                    memo.storeN(i,s);
                    end;
               end;
          end;
     end;


{SECTION  LoadBuffromSTRA }
Function LoadBuffromSTRA(var buf : MEMObuftype; var memo : STRA_object;
                    var endflag : boolean; var ii,jj : integer):boolean;
{ need to be handed an initialized STRA object, ii & jj can point to middle
   of STRA from a previous buffer. Calling program sets ii,jj := 0; first time}
var k         : integer;
    s         : string;
    by        : byte;
     begin
     k := 1;
     LoadBuffromSTRA := false;
     endflag := true;
     fillchar(buf,sizeof(buf),0);
     if memo.count = 0 then exit;
     while ii < memo.count do
          begin
          inc(ii);
          s := memo.fetchN(ii);
          while jj < length(s) do
               begin
               inc(jj);
               by := byte(s[jj]);
               if      by = $8A then buf[k] := $0A
               else if by = $FE then buf[k] := $1A
               else                  buf[k] := by;
               inc(k);
               if k > mblksize then
                    begin
                    dec(ii); { so we can finish the line next time}
                   { writeln('RETURNING PART buffer ',ii,' ',jj,' ',k);}
                    LoadBuffromSTRA := true;
                    endflag := false;
                    exit;
                    end;
               end;
          jj := 0;
          end;
    { writeln('RETURNING LAST buffer ',ii,' ',jj,' ',k);}
     LoadBuffromSTRA := true;
     end;


Function MemoBlocksNeeded(var memo : STRA_object) : integer;
var blocks,ii,jj : integer;
    endflag      : boolean;
    buf          : MEMObuftype;
     begin
     ii := 0; jj := 0; blocks := 0; endflag := false;
     fillchar(buf,sizeof(buf),0);
     while not endflag do
         begin
         if LoadBuffromSTRA(buf,memo,endflag,ii,jj) then inc(blocks);
         end;
     MemoBlocksNeeded := blocks;
     end;


{SECTION MEMO_object }

Procedure MEMO_object.init(fname : string; dbfmode : integer);
var create : boolean;
     begin
     opened := false; recs := 1; err := 0;
     create := false;
     if dbfmode = fCREATE then create := true;
     fillchar(mbuf,sizeof(mbuf),0);
     BFILE_object.InitWithHdr(fname,mblksize,mblksize,dbfmode);
     if create then
          begin
          UpDateHeader;
          UpDateHeader; {since UpdateHeader does filesize, do it twice}
         { writeln('memo object create ',recs);}
          if not NoError then writeln('UpdateHeader error ',err);
          end;
     if NoError then
          ReadHeader
     else writeln('BFILE_object err ',err);
     end;


Procedure MEMO_object.ReadHeader;
     begin
     if hdrptr = NIL then
         begin
         writeln('PbMEMO BFILE header problem ');
         exit;
         end;
     BFILE_object.ReadHeader;
     if not NoError then writeln('ReadHeader error ',err);
     move(hdrptr^,recs,4);
   {  writeln('ReadHeader ',recs);}
     end;


Procedure MEMO_object.UpdateHeader;
     begin {NOTE: A4 only writes for the actual length of the memo,
                   so the last block is always partial and the intervening
                   space is garbage.  I always write full blocks.}
     if hdrptr = NIL then
         begin
         writeln('PbMEMO BFILE header problem ');
         exit;
         end;
     recs := (filesize(fil)+(mblksize-1)) div mblksize;
     move(recs,hdrptr^,4);
     BFILE_object.UpdateHeader;
     end;



Function  MEMO_object.fetchN( ndx : MemoNdx; var memo : STRA_object;
                                var blocks : integer) : boolean;
var eorflag,ok : boolean;
    i            : integer;
    holder       : string;
     begin
     err := 0;
     holder := '';
     eorflag := false;
     ok := true;
     i := 0;
     blocks := 0;
     if ndx >= recs then
          begin
          fetchN := false;
          err    := 1;
          exit;
          end;
     while not eorflag and ok do
          begin
          if BFILE_object.fetchN(ndx+i,mbuf) then
               begin
               LoadSTRAfromBuf(mbuf,memo,eorflag,holder);
               inc(i);
               blocks := i;
               end
          else ok := false;
          end;
     fetchN := ok;
     end;


Function  MEMO_object.MemoBlocksN ( ndx : MemoNdx) : integer;
var eorflag,ok : boolean;
    i,j,blocks   : integer;
     begin
     err := 0;
     MemoBlocksN := 0;
     if ndx >= recs then exit;
     if ndx < 1    then exit;
     eorflag := false;
     ok := true;  i := 0; blocks := 0;
     while not eorflag and ok do
          begin
          if BFILE_object.fetchN(ndx+i,mbuf) then
               begin
               for j := 1 to mblksize do
                   if mbuf[j] = $1A then eorflag := true;
               inc(i);
               blocks := i;
               end
          else ok := false;
          end;
     MemoBlocksN := blocks;
     end;



Function  MEMO_object.storeN(var memo : STRA_object;
                 var ndx : MemoNdx; var blocks : integer) : boolean;
var needb, currb, i,ii,jj, bnum : integer;
    endflag : boolean;
     begin
     err := 0;
     PrepareSTRAforOutput(memo);
     currb := MemoBlocksN(ndx);
     needb := MemoBlocksNeeded(memo);
{     if needb > currb then
          writeln('MEMO_object  - StoreN ',' mnum:',ndx:5,'  mlines:',memo.count,
                  '  currb:',currb,'   needb:',needb); }
     if needb > currb then ndx := -1;  {append}
     ii := 0; jj := 0; blocks := 0; endflag := false;
     while not endflag do
          begin
          fillchar(mbuf,sizeof(mbuf),0);
          if LoadBuffromSTRA(mbuf,memo,endflag,ii,jj) then
               begin
               if ndx > 0 then bnum := ndx + blocks
               else bnum := recs + blocks;
              { writeln('writing MEMO curr:',recs,'  new:',bnum);}
               BFILE_object.storeN(bnum,mbuf);
               if err <> 0 then writeln('BFILE_object.storeN error ',err);
               inc(blocks);
               end;
          end;
     if ndx = -1 then ndx  := recs;   {first after old eof }
     UpdateHeader;                    {update header to new size}
     storeN := NoError;
     end;


Function  MEMO_object.append(var memo : STRA_object;
                 var ndx : MemoNdx; var blocks : integer) : boolean;
var needb : integer;
     begin
     err := 0;
     ndx := -1;
     append := storeN(memo,ndx,blocks);
     end;



Procedure MEMO_object.done;
     begin
     BFILE_object.done;
     end;


{SECTION  zzMEMOInit }
Procedure zzMEMOInit;
     begin
     end;


{SECTION  ZInitialization }
     begin {Initialization}
     zzMEMOinit;
     end.